home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / nnsoup.el.z / nnsoup.el
Encoding:
Text File  |  1998-05-21  |  25.8 KB  |  805 lines
  1. ;;; nnsoup.el --- SOUP access for Gnus
  2. ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;;; Code:
  28.  
  29. (require 'nnheader)
  30. (require 'nnmail)
  31. (require 'gnus-soup)
  32. (require 'gnus-msg)
  33. (require 'nnoo)
  34. (eval-when-compile (require 'cl))
  35.  
  36. (nnoo-declare nnsoup)
  37.  
  38. (defvoo nnsoup-directory "~/SOUP/"
  39.   "*SOUP packet directory.")
  40.  
  41. (defvoo nnsoup-tmp-directory "/tmp/"
  42.   "*Where nnsoup will store temporary files.")
  43.  
  44. (defvoo nnsoup-replies-directory (concat nnsoup-directory "replies/")
  45.   "*Directory where outgoing packets will be composed.")
  46.  
  47. (defvoo nnsoup-replies-format-type ?n
  48.   "*Format of the replies packages.")
  49.  
  50. (defvoo nnsoup-replies-index-type ?n
  51.   "*Index type of the replies packages.")
  52.  
  53. (defvoo nnsoup-active-file (concat nnsoup-directory "active")
  54.   "Active file.")
  55.  
  56. (defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz"
  57.   "Format string command for packing a SOUP packet.
  58. The SOUP files will be inserted where the %s is in the string.
  59. This string MUST contain both %s and %d.  The file number will be
  60. inserted where %d appears.")
  61.  
  62. (defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -"
  63.   "*Format string command for unpacking a SOUP packet.
  64. The SOUP packet file name will be inserted at the %s.")
  65.  
  66. (defvoo nnsoup-packet-directory "~/"
  67.   "*Where nnsoup will look for incoming packets.")
  68.  
  69. (defvoo nnsoup-packet-regexp "Soupout"
  70.   "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
  71.  
  72.  
  73.  
  74. (defconst nnsoup-version "nnsoup 0.0"
  75.   "nnsoup version.")
  76.  
  77. (defvoo nnsoup-status-string "")
  78. (defvoo nnsoup-group-alist nil)
  79. (defvoo nnsoup-current-prefix 0)
  80. (defvoo nnsoup-replies-list nil)
  81. (defvoo nnsoup-buffers nil)
  82. (defvoo nnsoup-current-group nil)
  83. (defvoo nnsoup-group-alist-touched nil)
  84. (defvoo nnsoup-article-alist nil)
  85.  
  86.  
  87.  
  88. ;;; Interface functions.
  89.  
  90. (nnoo-define-basics nnsoup)
  91.  
  92. (deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old)
  93.   (nnsoup-possibly-change-group group)
  94.   (save-excursion
  95.     (set-buffer nntp-server-buffer)
  96.     (erase-buffer)
  97.     (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist)))
  98.       (articles sequence)
  99.       (use-nov t)
  100.       useful-areas this-area-seq msg-buf)
  101.       (if (stringp (car sequence))
  102.       ;; We don't support fetching by Message-ID.
  103.       'headers
  104.     ;; We go through all the areas and find which files the
  105.     ;; articles in SEQUENCE come from.
  106.     (while (and areas sequence)
  107.       ;; Peel off areas that are below sequence.
  108.       (while (and areas (< (cdaar areas) (car sequence)))
  109.         (setq areas (cdr areas)))
  110.       (when areas
  111.         ;; This is a useful area.
  112.         (push (car areas) useful-areas)
  113.         (setq this-area-seq nil)
  114.         ;; We take note whether this MSG has a corresponding IDX
  115.         ;; for later use.
  116.         (when (or (= (gnus-soup-encoding-index
  117.               (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
  118.               (not (file-exists-p
  119.                 (nnsoup-file
  120.                  (gnus-soup-area-prefix (nth 1 (car areas)))))))
  121.           (setq use-nov nil))
  122.         ;; We assign the portion of `sequence' that is relevant to
  123.         ;; this MSG packet to this packet.
  124.         (while (and sequence (<= (car sequence) (cdaar areas)))
  125.           (push (car sequence) this-area-seq)
  126.           (setq sequence (cdr sequence)))
  127.         (setcar useful-areas (cons (nreverse this-area-seq)
  128.                        (car useful-areas)))))
  129.  
  130.     ;; We now have a list of article numbers and corresponding
  131.     ;; areas.
  132.     (setq useful-areas (nreverse useful-areas))
  133.  
  134.     ;; Two different approaches depending on whether all the MSG
  135.     ;; files have corresponding IDX files.  If they all do, we
  136.     ;; simply return the relevant IDX files and let Gnus sort out
  137.     ;; what lines are relevant.  If some of the IDX files are
  138.     ;; missing, we must return HEADs for all the articles.
  139.     (if use-nov
  140.         ;; We have IDX files for all areas.
  141.         (progn
  142.           (while useful-areas
  143.         (goto-char (point-max))
  144.         (let ((b (point))
  145.               (number (car (nth 1 (car useful-areas))))
  146.               (index-buffer (nnsoup-index-buffer
  147.                      (gnus-soup-area-prefix
  148.                       (nth 2 (car useful-areas))))))
  149.           (when index-buffer
  150.             (insert-buffer-substring index-buffer)
  151.             (goto-char b)
  152.             ;; We have to remove the index number entires and
  153.             ;; insert article numbers instead.
  154.             (while (looking-at "[0-9]+")
  155.               (replace-match (int-to-string number) t t)
  156.               (incf number)
  157.               (forward-line 1))))
  158.         (setq useful-areas (cdr useful-areas)))
  159.           'nov)
  160.       ;; We insert HEADs.
  161.       (while useful-areas
  162.         (setq articles (caar useful-areas)
  163.           useful-areas (cdr useful-areas))
  164.         (while articles
  165.           (when (setq msg-buf
  166.               (nnsoup-narrow-to-article
  167.                (car articles) (cdar useful-areas) 'head))
  168.         (goto-char (point-max))
  169.         (insert (format "221 %d Article retrieved.\n" (car articles)))
  170.         (insert-buffer-substring msg-buf)
  171.         (goto-char (point-max))
  172.         (insert ".\n"))
  173.           (setq articles (cdr articles))))
  174.  
  175.       (nnheader-fold-continuation-lines)
  176.       'headers)))))
  177.  
  178. (deffoo nnsoup-open-server (server &optional defs)
  179.   (nnoo-change-server 'nnsoup server defs)
  180.   (when (not (file-exists-p nnsoup-directory))
  181.     (condition-case ()
  182.     (make-directory nnsoup-directory t)
  183.       (error t)))
  184.   (cond
  185.    ((not (file-exists-p nnsoup-directory))
  186.     (nnsoup-close-server)
  187.     (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
  188.    ((not (file-directory-p (file-truename nnsoup-directory)))
  189.     (nnsoup-close-server)
  190.     (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory))
  191.    (t
  192.     (nnsoup-read-active-file)
  193.     (nnheader-report 'nnsoup "Opened server %s using directory %s"
  194.              server nnsoup-directory)
  195.     t)))
  196.  
  197. (deffoo nnsoup-request-close ()
  198.   (nnsoup-write-active-file)
  199.   (nnsoup-write-replies)
  200.   (gnus-soup-save-areas)
  201.   ;; Kill all nnsoup buffers.
  202.   (let (buffer)
  203.     (while nnsoup-buffers
  204.       (setq buffer (cdr (pop nnsoup-buffers)))
  205.       (and buffer
  206.        (buffer-name buffer)
  207.        (kill-buffer buffer))))
  208.   (setq nnsoup-group-alist nil
  209.     nnsoup-group-alist-touched nil
  210.     nnsoup-current-group nil
  211.     nnsoup-replies-list nil)
  212.   (nnoo-close-server 'nnoo)
  213.   t)
  214.  
  215. (deffoo nnsoup-request-article (id &optional newsgroup server buffer)
  216.   (nnsoup-possibly-change-group newsgroup)
  217.   (let (buf)
  218.     (save-excursion
  219.       (set-buffer (or buffer nntp-server-buffer))
  220.       (erase-buffer)
  221.       (when (and (not (stringp id))
  222.          (setq buf (nnsoup-narrow-to-article id)))
  223.     (insert-buffer-substring buf)
  224.     t))))
  225.  
  226. (deffoo nnsoup-request-group (group &optional server dont-check)
  227.   (nnsoup-possibly-change-group group)
  228.   (if dont-check
  229.       t
  230.     (let ((active (cadr (assoc group nnsoup-group-alist))))
  231.       (if (not active)
  232.       (nnheader-report 'nnsoup "No such group: %s" group)
  233.     (nnheader-insert
  234.      "211 %d %d %d %s\n"
  235.      (max (1+ (- (cdr active) (car active))) 0)
  236.      (car active) (cdr active) group)))))
  237.  
  238. (deffoo nnsoup-request-type (group &optional article)
  239.   (nnsoup-possibly-change-group group)
  240.   ;; Try to guess the type based on the first article in the group.
  241.   (when (not article)
  242.     (setq article
  243.       (cdaar (cddr (assoc group nnsoup-group-alist)))))
  244.   (if (not article)
  245.       'unknown
  246.     (let ((kind (gnus-soup-encoding-kind
  247.          (gnus-soup-area-encoding
  248.           (nth 1 (nnsoup-article-to-area
  249.               article nnsoup-current-group))))))
  250.       (cond ((= kind ?m) 'mail)
  251.         ((= kind ?n) 'news)
  252.         (t 'unknown)))))
  253.  
  254. (deffoo nnsoup-close-group (group &optional server)
  255.   ;; Kill all nnsoup buffers.
  256.   (let ((buffers nnsoup-buffers)
  257.     elem)
  258.     (while buffers
  259.       (when (equal (car (setq elem (pop buffers))) group)
  260.     (setq nnsoup-buffers (delq elem nnsoup-buffers))
  261.     (and (cdr elem) (buffer-name (cdr elem))
  262.          (kill-buffer (cdr elem))))))
  263.   t)
  264.  
  265. (deffoo nnsoup-request-list (&optional server)
  266.   (save-excursion
  267.     (set-buffer nntp-server-buffer)
  268.     (erase-buffer)
  269.     (unless nnsoup-group-alist
  270.       (nnsoup-read-active-file))
  271.     (let ((alist nnsoup-group-alist)
  272.       (standard-output (current-buffer))
  273.       entry)
  274.       (while (setq entry (pop alist))
  275.     (insert (car entry) " ")
  276.     (princ (cdadr entry))
  277.     (insert " ")
  278.     (princ (caadr entry))
  279.     (insert " y\n"))
  280.       t)))
  281.  
  282. (deffoo nnsoup-request-scan (group &optional server)
  283.   (nnsoup-unpack-packets))
  284.  
  285. (deffoo nnsoup-request-newgroups (date &optional server)
  286.   (nnsoup-request-list))
  287.  
  288. (deffoo nnsoup-request-list-newsgroups (&optional server)
  289.   nil)
  290.  
  291. (deffoo nnsoup-request-post (&optional server)
  292.   (nnsoup-store-reply "news")
  293.   t)
  294.  
  295. (deffoo nnsoup-request-mail (&optional server)
  296.   (nnsoup-store-reply "mail")
  297.   t)
  298.  
  299. (deffoo nnsoup-request-expire-articles (articles group &optional server force)
  300.   (nnsoup-possibly-change-group group)
  301.   (let* ((total-infolist (assoc group nnsoup-group-alist))
  302.      (active (cadr total-infolist))
  303.      (infolist (cddr total-infolist))
  304.      info range-list mod-time prefix)
  305.     (while infolist
  306.       (setq info (pop infolist)
  307.         range-list (gnus-uncompress-range (car info))
  308.         prefix (gnus-soup-area-prefix (nth 1 info)))
  309.       (when ;; All the articles in this file are marked for expiry.
  310.       (and (or (setq mod-time (nth 5 (file-attributes
  311.                       (nnsoup-file prefix))))
  312.            (setq mod-time (nth 5 (file-attributes
  313.                       (nnsoup-file prefix t)))))
  314.            (gnus-sublist-p articles range-list)
  315.            ;; This file is old enough.
  316.            (nnmail-expired-article-p group mod-time force))
  317.     ;; Ok, we delete this file.
  318.     (when (ignore-errors
  319.         (nnheader-message
  320.          5 "Deleting %s in group %s..." (nnsoup-file prefix)
  321.          group)
  322.         (when (file-exists-p (nnsoup-file prefix))
  323.           (delete-file (nnsoup-file prefix)))
  324.         (nnheader-message
  325.          5 "Deleting %s in group %s..." (nnsoup-file prefix t)
  326.          group)
  327.         (when (file-exists-p (nnsoup-file prefix t))
  328.           (delete-file (nnsoup-file prefix t)))
  329.         t)
  330.       (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
  331.       (setq articles (gnus-sorted-complement articles range-list))))
  332.       (when (not mod-time)
  333.     (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
  334.     (if (cddr total-infolist)
  335.     (setcar active (caaadr (cdr total-infolist)))
  336.       (setcar active (1+ (cdr active))))
  337.     (nnsoup-write-active-file t)
  338.     ;; Return the articles that weren't expired.
  339.     articles))
  340.  
  341.  
  342. ;;; Internal functions
  343.  
  344. (defun nnsoup-possibly-change-group (group &optional force)
  345.   (when (and group
  346.          (not (equal nnsoup-current-group group)))
  347.     (setq nnsoup-article-alist nil)
  348.     (setq nnsoup-current-group group))
  349.   t)
  350.  
  351. (defun nnsoup-read-active-file ()
  352.   (setq nnsoup-group-alist nil)
  353.   (when (file-exists-p nnsoup-active-file)
  354.     (ignore-errors
  355.       (load nnsoup-active-file t t t))
  356.     ;; Be backwards compatible.
  357.     (when (and nnsoup-group-alist
  358.            (not (atom (caadar nnsoup-group-alist))))
  359.       (let ((alist nnsoup-group-alist)
  360.         entry e min max)
  361.     (while (setq e (cdr (setq entry (pop alist))))
  362.       (setq min (caaar e))
  363.       (while (cdr e)
  364.         (setq e (cdr e)))
  365.       (setq max (cdaar e))
  366.       (setcdr entry (cons (cons min max) (cdr entry)))))
  367.       (setq nnsoup-group-alist-touched t))
  368.     nnsoup-group-alist))
  369.  
  370. (defun nnsoup-write-active-file (&optional force)
  371.   (when (and nnsoup-group-alist
  372.          (or force
  373.          nnsoup-group-alist-touched))
  374.     (setq nnsoup-group-alist-touched nil)
  375.     (nnheader-temp-write nnsoup-active-file
  376.       (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
  377.       (insert "\n")
  378.       (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
  379.       (insert "\n"))))
  380.  
  381. (defun nnsoup-next-prefix ()
  382.   "Return the next free prefix."
  383.   (let (prefix)
  384.     (while (or (file-exists-p
  385.         (nnsoup-file (setq prefix (int-to-string
  386.                        nnsoup-current-prefix))))
  387.            (file-exists-p (nnsoup-file prefix t)))
  388.       (incf nnsoup-current-prefix))
  389.     (incf nnsoup-current-prefix)
  390.     prefix))
  391.  
  392. (defun nnsoup-file-name (dir file)
  393.   "Return the full path of FILE (in any case) in DIR."
  394.   (let* ((case-fold-search t)
  395.      (files (directory-files dir t))
  396.      (regexp (concat (regexp-quote file) "$")))
  397.     (car (delq nil
  398.            (mapcar
  399.         (lambda (file)
  400.           (if (string-match regexp file)
  401.               file
  402.             nil))
  403.         files)))))
  404.  
  405. (defun nnsoup-read-areas ()
  406.   (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas")))
  407.     (when areas-file
  408.       (save-excursion
  409.     (set-buffer nntp-server-buffer)
  410.     (let ((areas (gnus-soup-parse-areas areas-file))
  411.           entry number area lnum cur-prefix file)
  412.       ;; Go through all areas in the new AREAS file.
  413.       (while (setq area (pop areas))
  414.         ;; Change the name to the permanent name and move the files.
  415.         (setq cur-prefix (nnsoup-next-prefix))
  416.         (message "Incorporating file %s..." cur-prefix)
  417.         (when (file-exists-p
  418.            (setq file (concat nnsoup-tmp-directory
  419.                       (gnus-soup-area-prefix area) ".IDX")))
  420.           (rename-file file (nnsoup-file cur-prefix)))
  421.         (when (file-exists-p
  422.            (setq file (concat nnsoup-tmp-directory
  423.                       (gnus-soup-area-prefix area) ".MSG")))
  424.           (rename-file file (nnsoup-file cur-prefix t))
  425.           (gnus-soup-set-area-prefix area cur-prefix)
  426.           ;; Find the number of new articles in this area.
  427.           (setq number (nnsoup-number-of-articles area))
  428.           (if (not (setq entry (assoc (gnus-soup-area-name area)
  429.                       nnsoup-group-alist)))
  430.           ;; If this is a new area (group), we just add this info to
  431.           ;; the group alist.
  432.           (push (list (gnus-soup-area-name area)
  433.                   (cons 1 number)
  434.                   (list (cons 1 number) area))
  435.             nnsoup-group-alist)
  436.         ;; There are already articles in this group, so we add this
  437.         ;; info to the end of the entry.
  438.         (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
  439.                            (+ lnum number))
  440.                      area)))
  441.         (setcdr (cadr entry) (+ lnum number))))))
  442.     (nnsoup-write-active-file t)
  443.     (delete-file areas-file)))))
  444.  
  445. (defun nnsoup-number-of-articles (area)
  446.   (save-excursion
  447.     (cond
  448.      ;; If the number is in the area info, we just return it.
  449.      ((gnus-soup-area-number area)
  450.       (gnus-soup-area-number area))
  451.      ;; If there is an index file, we just count the lines.
  452.      ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
  453.       (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
  454.       (count-lines (point-min) (point-max)))
  455.      ;; We do it the hard way - re-searching through the message
  456.      ;; buffer.
  457.      (t
  458.       (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
  459.       (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist)
  460.     (nnsoup-dissect-buffer area))
  461.       (length (cdr (assoc (gnus-soup-area-prefix area)
  462.               nnsoup-article-alist)))))))
  463.  
  464. (defun nnsoup-dissect-buffer (area)
  465.   (let ((mbox-delim (concat "^" message-unix-mail-delimiter))
  466.     (format (gnus-soup-encoding-format (gnus-soup-area-encoding area)))
  467.     (i 0)
  468.     alist len)
  469.     (goto-char (point-min))
  470.     (cond
  471.      ;; rnews batch format
  472.      ((= format ?n)
  473.       (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$")
  474.     (forward-line 1)
  475.     (push (list
  476.            (incf i) (point)
  477.            (progn
  478.          (forward-char (string-to-number (match-string 1)))
  479.          (point)))
  480.           alist)))
  481.      ;; Unix mbox format
  482.      ((= format ?m)
  483.       (while (looking-at mbox-delim)
  484.     (forward-line 1)
  485.     (push (list
  486.            (incf i) (point)
  487.            (progn
  488.          (if (re-search-forward mbox-delim nil t)
  489.              (beginning-of-line)
  490.            (goto-char (point-max)))
  491.          (point)))
  492.           alist)))
  493.      ;; MMDF format
  494.      ((= format ?M)
  495.       (while (looking-at "\^A\^A\^A\^A\n")
  496.     (forward-line 1)
  497.     (push (list
  498.            (incf i) (point)
  499.            (progn
  500.          (if (search-forward "\n\^A\^A\^A\^A\n" nil t)
  501.              (beginning-of-line)
  502.            (goto-char (point-max)))
  503.          (point)))
  504.           alist)))
  505.      ;; Binary format
  506.      ((or (= format ?B) (= format ?b))
  507.       (while (not (eobp))
  508.     (setq len (+ (* (char-after (point)) (expt 2.0 24))
  509.              (* (char-after (+ (point) 1)) (expt 2 16))
  510.              (* (char-after (+ (point) 2)) (expt 2 8))
  511.              (char-after (+ (point) 3))))
  512.     (push (list
  513.            (incf i) (+ (point) 4)
  514.            (progn
  515.          (forward-char (floor (+ len 4)))
  516.          (point)))
  517.           alist)))
  518.      (t
  519.       (error "Unknown format: %c" format)))
  520.     (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist)))
  521.  
  522. (defun nnsoup-index-buffer (prefix &optional message)
  523.   (let* ((file (concat prefix (if message ".MSG" ".IDX")))
  524.      (buffer-name (concat " *nnsoup " file "*")))
  525.     (or (get-buffer buffer-name)    ; File already loaded.
  526.     (when (file-exists-p (concat nnsoup-directory file))
  527.       (save-excursion        ; Load the file.
  528.         (set-buffer (get-buffer-create buffer-name))
  529.         (buffer-disable-undo (current-buffer))
  530.         (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
  531.         (nnheader-insert-file-contents (concat nnsoup-directory file))
  532.         (current-buffer))))))
  533.  
  534. (defun nnsoup-file (prefix &optional message)
  535.   (expand-file-name
  536.    (concat nnsoup-directory prefix (if message ".MSG" ".IDX"))))
  537.  
  538. (defun nnsoup-message-buffer (prefix)
  539.   (nnsoup-index-buffer prefix 'msg))
  540.  
  541. (defun nnsoup-unpack-packets ()
  542.   "Unpack all packets in `nnsoup-packet-directory'."
  543.   (let ((packets (directory-files
  544.           nnsoup-packet-directory t nnsoup-packet-regexp))
  545.     packet)
  546.     (while (setq packet (pop packets))
  547.       (message "nnsoup: unpacking %s..." packet)
  548.       (if (not (gnus-soup-unpack-packet
  549.         nnsoup-tmp-directory nnsoup-unpacker packet))
  550.       (message "Couldn't unpack %s" packet)
  551.     (delete-file packet)
  552.     (nnsoup-read-areas)
  553.     (message "Unpacking...done")))))
  554.  
  555. (defun nnsoup-narrow-to-article (article &optional area head)
  556.   (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
  557.      (prefix (and area (gnus-soup-area-prefix (nth 1 area))))
  558.      (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg)))
  559.      beg end)
  560.     (when area
  561.       (save-excursion
  562.     (cond
  563.      ;; There is no MSG file.
  564.      ((null msg-buf)
  565.       nil)
  566.      ;; We use the index file to find out where the article
  567.      ;; begins and ends.
  568.      ((and (= (gnus-soup-encoding-index
  569.            (gnus-soup-area-encoding (nth 1 area)))
  570.           ?c)
  571.            (file-exists-p (nnsoup-file prefix)))
  572.       (set-buffer (nnsoup-index-buffer prefix))
  573.       (widen)
  574.       (goto-char (point-min))
  575.       (forward-line (- article (caar area)))
  576.       (setq beg (read (current-buffer)))
  577.       (forward-line 1)
  578.       (if (looking-at "[0-9]+")
  579.           (progn
  580.         (setq end (read (current-buffer)))
  581.         (set-buffer msg-buf)
  582.         (widen)
  583.         (let ((format (gnus-soup-encoding-format
  584.                    (gnus-soup-area-encoding (nth 1 area)))))
  585.           (goto-char end)
  586.           (when (or (= format ?n) (= format ?m))
  587.             (setq end (progn (forward-line -1) (point))))))
  588.         (set-buffer msg-buf))
  589.       (widen)
  590.       (narrow-to-region beg (or end (point-max))))
  591.      (t
  592.       (set-buffer msg-buf)
  593.       (widen)
  594.       (unless (assoc (gnus-soup-area-prefix (nth 1 area))
  595.              nnsoup-article-alist)
  596.         (nnsoup-dissect-buffer (nth 1 area)))
  597.       (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix
  598.                           (nth 1 area))
  599.                          nnsoup-article-alist)))))
  600.         (when entry
  601.           (narrow-to-region (cadr entry) (caddr entry))))))
  602.     (goto-char (point-min))
  603.     (if (not head)
  604.         ()
  605.       (narrow-to-region
  606.        (point-min)
  607.        (if (search-forward "\n\n" nil t)
  608.            (1- (point))
  609.          (point-max))))
  610.     msg-buf))))
  611.  
  612. ;;;###autoload
  613. (defun nnsoup-pack-replies ()
  614.   "Make an outbound package of SOUP replies."
  615.   (interactive)
  616.   (unless (file-exists-p nnsoup-replies-directory)
  617.     (message "No such directory: %s" nnsoup-replies-directory))
  618.   ;; Write all data buffers.
  619.   (gnus-soup-save-areas)
  620.   ;; Write the active file.
  621.   (nnsoup-write-active-file)
  622.   ;; Write the REPLIES file.
  623.   (nnsoup-write-replies)
  624.   ;; Check whether there is anything here.
  625.   (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$"))
  626.     (error "No files to pack"))
  627.   ;; Pack all these files into a SOUP packet.
  628.   (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
  629.  
  630. (defun nnsoup-write-replies ()
  631.   "Write the REPLIES file."
  632.   (when nnsoup-replies-list
  633.     (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
  634.     (setq nnsoup-replies-list nil)))
  635.  
  636. (defun nnsoup-article-to-area (article group)
  637.   "Return the area that ARTICLE in GROUP is located in."
  638.   (let ((areas (cddr (assoc group nnsoup-group-alist))))
  639.     (while (and areas (< (cdaar areas) article))
  640.       (setq areas (cdr areas)))
  641.     (and areas (car areas))))
  642.  
  643. (defvar nnsoup-old-functions
  644.   (list message-send-mail-function message-send-news-function))
  645.  
  646. ;;;###autoload
  647. (defun nnsoup-set-variables ()
  648.   "Use the SOUP methods for posting news and mailing mail."
  649.   (interactive)
  650.   (setq message-send-news-function 'nnsoup-request-post)
  651.   (setq message-send-mail-function 'nnsoup-request-mail))
  652.  
  653. ;;;###autoload
  654. (defun nnsoup-revert-variables ()
  655.   "Revert posting and mailing methods to the standard Emacs methods."
  656.   (interactive)
  657.   (setq message-send-mail-function (car nnsoup-old-functions))
  658.   (setq message-send-news-function (cadr nnsoup-old-functions)))
  659.  
  660. (defun nnsoup-store-reply (kind)
  661.   ;; Mostly stolen from `message.el'.
  662.   (require 'mail-utils)
  663.   (let ((tembuf (generate-new-buffer " message temp"))
  664.     (case-fold-search nil)
  665.     delimline
  666.     (mailbuf (current-buffer)))
  667.     (unwind-protect
  668.     (save-excursion
  669.       (save-restriction
  670.         (message-narrow-to-headers)
  671.         (if (equal kind "mail")
  672.         (message-generate-headers message-required-mail-headers)
  673.           (message-generate-headers message-required-news-headers)))
  674.       (set-buffer tembuf)
  675.       (erase-buffer)
  676.       (insert-buffer-substring mailbuf)
  677.       ;; Remove some headers.
  678.       (save-restriction
  679.         (message-narrow-to-headers)
  680.         ;; Remove some headers.
  681.         (message-remove-header message-ignored-mail-headers t))
  682.       (goto-char (point-max))
  683.       ;; require one newline at the end.
  684.       (or (= (preceding-char) ?\n)
  685.           (insert ?\n))
  686.       (let ((case-fold-search t))
  687.         ;; Change header-delimiter to be what sendmail expects.
  688.         (goto-char (point-min))
  689.         (re-search-forward
  690.          (concat "^" (regexp-quote mail-header-separator) "\n"))
  691.         (replace-match "\n")
  692.         (backward-char 1)
  693.         (setq delimline (point-marker))
  694.         ;; Insert an extra newline if we need it to work around
  695.         ;; Sun's bug that swallows newlines.
  696.         (goto-char (1+ delimline))
  697.         (when (eval message-mailer-swallows-blank-line)
  698.           (newline))
  699.         (let ((msg-buf
  700.            (gnus-soup-store
  701.             nnsoup-replies-directory
  702.             (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
  703.             nnsoup-replies-index-type))
  704.           (num 0))
  705.           (when (and msg-buf (bufferp msg-buf))
  706.         (save-excursion
  707.           (set-buffer msg-buf)
  708.           (goto-char (point-min))
  709.           (while (re-search-forward "^#! *rnews" nil t)
  710.             (incf num)))
  711.         (message "Stored %d messages" num)))
  712.         (nnsoup-write-replies)
  713.         (kill-buffer tembuf))))))
  714.  
  715. (defun nnsoup-kind-to-prefix (kind)
  716.   (unless nnsoup-replies-list
  717.     (setq nnsoup-replies-list
  718.       (gnus-soup-parse-replies
  719.        (concat nnsoup-replies-directory "REPLIES"))))
  720.   (let ((replies nnsoup-replies-list))
  721.     (while (and replies
  722.         (not (string= kind (gnus-soup-reply-kind (car replies)))))
  723.       (setq replies (cdr replies)))
  724.     (if replies
  725.     (gnus-soup-reply-prefix (car replies))
  726.       (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
  727.             kind
  728.             (format "%c%c%c"
  729.                 nnsoup-replies-format-type
  730.                 nnsoup-replies-index-type
  731.                 (if (string= kind "news")
  732.                 ?n ?m)))
  733.         nnsoup-replies-list)
  734.       (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
  735.  
  736. (defun nnsoup-make-active ()
  737.   "(Re-)create the SOUP active file."
  738.   (interactive)
  739.   (let ((files (sort (directory-files nnsoup-directory t "IDX$")
  740.              (lambda (f1 f2)
  741.                (< (progn (string-match "/\\([0-9]+\\)\\." f1)
  742.                  (string-to-int (match-string 1 f1)))
  743.               (progn (string-match "/\\([0-9]+\\)\\." f2)
  744.                  (string-to-int (match-string 1 f2)))))))
  745.     active group lines ident elem min)
  746.     (set-buffer (get-buffer-create " *nnsoup work*"))
  747.     (buffer-disable-undo (current-buffer))
  748.     (while files
  749.       (message "Doing %s..." (car files))
  750.       (erase-buffer)
  751.       (nnheader-insert-file-contents (car files))
  752.       (goto-char (point-min))
  753.       (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t))
  754.       (setq group "unknown")
  755.     (setq group (match-string 2)))
  756.       (setq lines (count-lines (point-min) (point-max)))
  757.       (setq ident (progn (string-match
  758.               "/\\([0-9]+\\)\\." (car files))
  759.              (substring
  760.               (car files) (match-beginning 1)
  761.               (match-end 1))))
  762.       (if (not (setq elem (assoc group active)))
  763.       (push (list group (cons 1 lines)
  764.               (list (cons 1 lines)
  765.                 (vector ident group "ncm" "" lines)))
  766.         active)
  767.     (nconc elem
  768.            (list
  769.         (list (cons (1+ (setq min (cdadr elem)))
  770.                 (+ min lines))
  771.               (vector ident group "ncm" "" lines))))
  772.     (setcdr (cadr elem) (+ min lines)))
  773.       (setq files (cdr files)))
  774.     (message "")
  775.     (setq nnsoup-group-alist active)
  776.     (nnsoup-write-active-file t)))
  777.  
  778. (defun nnsoup-delete-unreferenced-message-files ()
  779.   "Delete any *.MSG and *.IDX files that aren't known by nnsoup."
  780.   (interactive)
  781.   (let* ((known (apply 'nconc (mapcar
  782.                    (lambda (ga)
  783.                  (mapcar
  784.                   (lambda (area)
  785.                     (gnus-soup-area-prefix (cadr area)))
  786.                   (cddr ga)))
  787.                    nnsoup-group-alist)))
  788.      (regexp "\\.MSG$\\|\\.IDX$")
  789.      (files (directory-files nnsoup-directory nil regexp))
  790.      non-files file)
  791.     ;; Find all files that aren't known by nnsoup.
  792.     (while (setq file (pop files))
  793.       (string-match regexp file)
  794.       (unless (member (substring file 0 (match-beginning 0)) known)
  795.     (push file non-files)))
  796.     ;; Sort and delete the files.
  797.     (setq non-files (sort non-files 'string<))
  798.     (map-y-or-n-p "Delete file %s? "
  799.           (lambda (file) (delete-file (concat nnsoup-directory file)))
  800.           non-files)))
  801.  
  802. (provide 'nnsoup)
  803.  
  804. ;;; nnsoup.el ends here
  805.